home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 176_01 / xlobj.c < prev    next >
Text File  |  1985-10-03  |  13KB  |  499 lines
  1. /* xlobj - xlisp object functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE ***xlstack,*xlenv;
  14. extern NODE *s_stdout;
  15. extern NODE *self,*msgclass,*msgcls,*class,*object;
  16. extern NODE *new,*isnew;
  17.  
  18. /* instance variable numbers for the class 'Class' */
  19. #define MESSAGES    0    /* list of messages */
  20. #define IVARS        1    /* list of instance variable names */
  21. #define CVARS        2    /* list of class variable names */
  22. #define CVALS        3    /* list of class variable values */
  23. #define SUPERCLASS    4    /* pointer to the superclass */
  24. #define IVARCNT        5    /* number of class instance variables */
  25. #define IVARTOTAL    6    /* total number of instance variables */
  26.  
  27. /* number of instance variables for the class 'Class' */
  28. #define CLASSSIZE    7
  29.  
  30. /* forward declarations */
  31. FORWARD NODE *entermsg();
  32. FORWARD NODE *findmsg();
  33. FORWARD NODE *sendmsg();
  34.  
  35. /* xlclass - define a class */
  36. NODE *xlclass(name,vcnt)
  37.   char *name; int vcnt;
  38. {
  39.     NODE *sym,*cls;
  40.  
  41.     /* create the class */
  42.     sym = xlsenter(name);
  43.     cls = newobject(class,CLASSSIZE);
  44.     setvalue(sym,cls);
  45.  
  46.     /* set the instance variable counts */
  47.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
  48.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
  49.  
  50.     /* set the superclass to 'Object' */
  51.     setivar(cls,SUPERCLASS,object);
  52.  
  53.     /* return the new class */
  54.     return (cls);
  55. }
  56.  
  57. /* xladdivar - enter an instance variable */
  58. xladdivar(cls,var)
  59.   NODE *cls; char *var;
  60. {
  61.     setivar(cls,IVARS,cons(xlsenter(var),getivar(cls,IVARS)));
  62. }
  63.  
  64. /* xladdmsg - add a message to a class */
  65. xladdmsg(cls,msg,code)
  66.   NODE *cls; char *msg; NODE *(*code)();
  67. {
  68.     NODE *mptr;
  69.  
  70.     /* enter the message selector */
  71.     mptr = entermsg(cls,xlsenter(msg));
  72.  
  73.     /* store the method for this message */
  74.     rplacd(mptr,cvsubr(code,SUBR));
  75. }
  76.  
  77. /* xlsend - send a message to an object (message in arg list) */
  78. NODE *xlsend(obj,args)
  79.   NODE *obj,*args;
  80. {
  81.     NODE ***oldstk,*arglist,*msg,*val;
  82.  
  83.     /* find the message binding for this message */
  84.     if ((msg = findmsg(getclass(obj),xlevmatch(SYM,&args))) == NIL)
  85.     xlfail("no method for this message");
  86.  
  87.     /* evaluate the arguments and send the message */
  88.     oldstk = xlsave(&arglist,NULL);
  89.     arglist = xlevlist(args);
  90.     val = sendmsg(obj,msg,arglist);
  91.     xlstack = oldstk;
  92.  
  93.     /* return the result */
  94.     return (val);
  95. }
  96.  
  97. /* xlobgetvalue - get the value of an instance variable */
  98. int xlobgetvalue(sym,pval)
  99.   NODE *sym,**pval;
  100. {
  101.     NODE *obj,*cls,*names;
  102.     int ivtotal,n;
  103.  
  104.     /* get the current object and the message class */
  105.     obj = xlygetvalue(self);
  106.     cls = xlygetvalue(msgclass);
  107.     if (!(objectp(obj) && objectp(cls)))
  108.     return (FALSE);
  109.  
  110.     /* find the instance or class variable */
  111.     for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  112.  
  113.     /* check the instance variables */
  114.     names = getivar(cls,IVARS);
  115.     ivtotal = getivcnt(cls,IVARTOTAL);
  116.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  117.         if (car(names) == sym) {
  118.         *pval = getivar(obj,n);
  119.         return (TRUE);
  120.         }
  121.         names = cdr(names);
  122.     }
  123.  
  124.     /* check the class variables */
  125.     names = getivar(cls,CVARS);
  126.     for (n = 0; consp(names); ++n) {
  127.         if (car(names) == sym) {
  128.         *pval = getelement(getivar(cls,CVALS),n);
  129.         return (TRUE);
  130.         }
  131.         names = cdr(names);
  132.     }
  133.     }
  134.  
  135.     /* variable not found */
  136.     return (FALSE);
  137. }
  138.  
  139. /* xlobsetvalue - set the value of an instance variable */
  140. int xlobsetvalue(sym,val)
  141.   NODE *sym,*val;
  142. {
  143.     NODE *obj,*cls,*names;
  144.     int ivtotal,n;
  145.  
  146.     /* get the current object and the message class */
  147.     obj = xlygetvalue(self);
  148.     cls = xlygetvalue(msgclass);
  149.     if (!(objectp(obj) && objectp(cls)))
  150.     return (FALSE);
  151.  
  152.     /* find the instance or class variable */
  153.     for (; objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  154.  
  155.     /* check the instance variables */
  156.     names = getivar(cls,IVARS);
  157.     ivtotal = getivcnt(cls,IVARTOTAL);
  158.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  159.         if (car(names) == sym) {
  160.         setivar(obj,n,val);
  161.         return (TRUE);
  162.         }
  163.         names = cdr(names);
  164.     }
  165.  
  166.     /* check the class variables */
  167.     names = getivar(cls,CVARS);
  168.     for (n = 0; consp(names); ++n) {
  169.         if (car(names) == sym) {
  170.         setelement(getivar(cls,CVALS),n,val);
  171.         return (TRUE);
  172.         }
  173.         names = cdr(names);
  174.     }
  175.     }
  176.  
  177.     /* variable not found */
  178.     return (FALSE);
  179. }
  180.  
  181. /* obisnew - default 'isnew' method */
  182. LOCAL NODE *obisnew(args)
  183.   NODE *args;
  184. {
  185.     xllastarg(args);
  186.     return (xlygetvalue(self));
  187. }
  188.  
  189. /* obclass - get the class of an object */
  190. LOCAL NODE *obclass(args)
  191.   NODE *args;
  192. {
  193.     /* make sure there aren't any arguments */
  194.     xllastarg(args);
  195.  
  196.     /* return the object's class */
  197.     return (getclass(xlygetvalue(self)));
  198. }
  199.  
  200. /* obshow - show the instance variables of an object */
  201. LOCAL NODE *obshow(args)
  202.   NODE *args;
  203. {
  204.     NODE ***oldstk,*fptr,*obj,*cls,*names;
  205.     int ivtotal,n;
  206.  
  207.     /* create a new stack frame */
  208.     oldstk = xlsave(&fptr,NULL);
  209.  
  210.     /* get the file pointer */
  211.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  212.     xllastarg(args);
  213.  
  214.     /* get the object and its class */
  215.     obj = xlygetvalue(self);
  216.     cls = getclass(obj);
  217.  
  218.     /* print the object and class */
  219.     xlputstr(fptr,"Object is ");
  220.     xlprint(fptr,obj,TRUE);
  221.     xlputstr(fptr,", Class is ");
  222.     xlprint(fptr,cls,TRUE);
  223.     xlterpri(fptr);
  224.  
  225.     /* print the object's instance variables */
  226.     for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS)) {
  227.     names = getivar(cls,IVARS);
  228.     ivtotal = getivcnt(cls,IVARTOTAL);
  229.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  230.         xlputstr(fptr,"  ");
  231.         xlprint(fptr,car(names),TRUE);
  232.         xlputstr(fptr," = ");
  233.         xlprint(fptr,getivar(obj,n),TRUE);
  234.         xlterpri(fptr);
  235.         names = cdr(names);
  236.     }
  237.     }
  238.  
  239.     /* restore the previous stack frame */
  240.     xlstack = oldstk;
  241.  
  242.     /* return the object */
  243.     return (obj);
  244. }
  245.  
  246. /* obsendsuper - send a message to an object's superclass */
  247. LOCAL NODE *obsendsuper(args)
  248.   NODE *args;
  249. {
  250.     NODE *obj,*super,*msg;
  251.  
  252.     /* get the object */
  253.     obj = xlygetvalue(self);
  254.  
  255.     /* get the object's superclass */
  256.     super = getivar(getclass(obj),SUPERCLASS);
  257.  
  258.     /* find the message binding for this message */
  259.     if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
  260.     xlfail("no method for this message");
  261.  
  262.     /* send the message */
  263.     return (sendmsg(obj,msg,args));
  264. }
  265.  
  266. /* clnew - create a new object instance */
  267. LOCAL NODE *clnew()
  268. {
  269.     NODE *cls;
  270.     cls = xlygetvalue(self);
  271.     return (newobject(cls,getivcnt(cls,IVARTOTAL)));
  272. }
  273.  
  274. /* clisnew - initialize a new class */
  275. LOCAL NODE *clisnew(args)
  276.   NODE *args;
  277. {
  278.     NODE *ivars,*cvars,*super,*cls;
  279.     int n;
  280.  
  281.     /* get the ivars, cvars and superclass */
  282.     ivars = xlmatch(LIST,&args);
  283.     cvars = (args ? xlmatch(LIST,&args) : NIL);
  284.     super = (args ? xlmatch(OBJ,&args) : object);
  285.     xllastarg(args);
  286.  
  287.     /* get the new class object */
  288.     cls = xlygetvalue(self);
  289.  
  290.     /* store the instance and class variable lists and the superclass */
  291.     setivar(cls,IVARS,ivars);
  292.     setivar(cls,CVARS,cvars);
  293.     setivar(cls,CVALS,newvector(listlength(cvars)));
  294.     setivar(cls,SUPERCLASS,super);
  295.  
  296.     /* compute the instance variable count */
  297.     n = listlength(ivars);
  298.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
  299.     n += getivcnt(super,IVARTOTAL);
  300.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
  301.  
  302.     /* return the new class object */
  303.     return (cls);
  304. }
  305.  
  306. /* clanswer - define a method for answering a message */
  307. LOCAL NODE *clanswer(args)
  308.   NODE *args;
  309. {
  310.     NODE ***oldstk,*arg,*msg,*fargs,*code,*obj,*mptr;
  311.  
  312.     /* create a new stack frame */
  313.     oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
  314.  
  315.     /* initialize */
  316.     arg = args;
  317.  
  318.     /* message symbol, formal argument list and code */
  319.     msg = xlmatch(SYM,&arg);
  320.